﻿module TupleExtensions2
module Tuple =

    let const' _ x = x

    type Single<'a> = Single of 'a

    type Split = Split with
        static member ($) (_:Split, Single x1 ) = (x1, ())
        static member ($) (_:Split, (x1,x2) ) = (x1, Single x2)
        static member ($) (_:Split, (x1,x2,x3) ) = (x1, (x2,x3))
        static member ($) (_:Split, (x1,x2,x3,x4) ) = (x1, (x2,x3,x4))
        static member ($) (_:Split, (x1,x2,x3,x4,x5)) = (x1, (x2,x3,x4,x5))

    type Join = Join with
        static member ($) (_:Join, () ) = fun x -> Single x
        static member ($) (_:Join, Single x1 ) = fun x -> (x,x1)
        static member ($) (_:Join, (x1,x2) ) = fun x -> (x,x1,x2)
        static member ($) (_:Join, (x1,x2,x3) ) = fun x -> (x,x1,x2,x3)
        static member ($) (_:Join, (x1,x2,x3,x4)) = fun x -> (x,x1,x2,x3,x4)
    let inline (|Cons|) tuple = printfn "splitting" ; Split $ tuple

    let inline Cons (head,tail) = printfn "joining" ;Join $ tail <| head

    type Head = Head with static member inline ($) (i:Head,tuple) = (Split $ tuple) |> fst

    type Tail = Tail with static member inline ($) (i:Tail,tuple) = (Split $ tuple) |> snd

    type TypeAdapter< ^a> = TypeAdapter of ^a with static member inline ($) (TypeAdapter fn,x) = fn x

    type Ap = Ap with
        static member inline ($) (_:Ap, Cons(hf,tf) ) = fun (Cons(hx,tx)) -> Cons(hf hx, Ap $ tf <| tx) 
        static member ($) (_:Ap, () ) = ignore

    let inline (<*>) fnTuple tuple = Ap $ fnTuple <| tuple

    type MapType = MapType with
        static member inline (?<-) ((),_:MapType,f) = ()
        static member inline (?<-) (Single(x1),_:MapType,f) = Single(f $ x1)
        static member inline (?<-) ((x1,x2),_:MapType,f) = (f $ x1 ,f $ x2)
        static member inline (?<-) ((x1,x2,x3),_:MapType,f) = (f $ x1 ,f $ x2,f $ x3)
        static member inline (?<-) ((x1,x2,x3,x4),_:MapType,f) = (f $ x1 ,f $ x2,f $ x3,f $ x4)
        static member inline (?<-) ((x1,x2,x3,x4,x5),_:MapType,f) = (f $ x1 ,f $ x2,f $ x3,f $ x4,f $ x5)

    let inline mapType tf x :^r = x ? (MapType) <- tf

    type FoldType = FoldType with
        static member inline ($) (_:FoldType,() ) = fun f y -> y
        static member inline ($) (_:FoldType,Single x) = fun f y -> f $ y <| x
        static member inline ($) (_:FoldType,(x1,x2)) = fun f y -> f $ (f $ y <| x1) <| x2
        static member inline ($) (_:FoldType,(x1,x2,x3)) = fun f y -> f $ ( f $ (f $ y <| x1) <| x2) <| x3
        static member inline ($) (_:FoldType,(x1,x2,x3,x4)) = fun f y -> f $ (f $ ( f $ (f $ y <| x1) <| x2) <| x3) <| x4
        static member inline ($) (_:FoldType,(x1,x2,x3,x4,x5)) = fun f y -> f $ (f $ (f $ ( f $ (f $ y <| x1) <| x2) <| x3) <| x4) <| x5

    let inline foldType tf z tuple = (FoldType $ tuple ) tf z
    let inline fold f z tuple = foldType (TypeAdapter f) z tuple
    let inline map f tuple = mapType (TypeAdapter f) tuple
    let inline rev tuple = foldType Join () tuple
    let inline append tuple = foldType Join () tuple
    // type ToStr = ToStr with static member inline ($) (_:ToStr,x) = fun y -> x + (string y)
    // try foldType  ToStr  "" (1 , '2',  3)    
    
    let inline matsplit x = (x ? (MapType) <- Head) , (x ? (MapType) <- Tail)
    
    let inline head tuple = (Split $ tuple) |> fst
    let inline tail tuple = (Split $ tuple) |> snd

    type Transpose = Transpose with
        static member inline ($) (_:Transpose, matHead : ^a when ^a : not struct ) =
            fun mat acc ->
                let (matFirst,matRest) = matsplit mat
                let nextAcc = Cons(matFirst,acc)
                let headmatRest = head matRest
                Transpose $ headmatRest <| matRest <| nextAcc
        static member ($) (_:Transpose, ()) = const'
        
    let inline transpose mat = rev (Transpose $ head mat <| mat <| ())    


    let inline toList x = fold (fun t h -> h::t) [] x
    let inline toSeq x = List.toSeq (toList x)

    type ForwardApply<'a>  = ForwardApply of 'a with static member inline ($) (ForwardApply a,x) = x a
    let inline applySingle t x = mapType (ForwardApply x) t

    let inline last t = head (rev t)